home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / init.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  13.7 KB  |  325 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;;
  28. ;;; This file defines the initialization and related protocols.
  29. ;;; 
  30.  
  31. (in-package 'pcl)
  32.  
  33. (declaim (type boolean *check-initargs-p*))
  34. (defvar *check-initargs-p* nil)
  35.  
  36. (defmacro checking-initargs (&body forms)
  37.   `(when *check-initargs-p* ,@forms))
  38.  
  39. (declaim (type boolean *making-instance-p*))
  40. (defvar *making-instance-p* nil)
  41.  
  42. (defmethod make-instance ((class slot-class) &rest initargs)
  43.   (declare (list initargs))
  44.   (unless (class-finalized-p class) (finalize-inheritance class))
  45.   (let ((class-default-initargs (class-default-initargs class)))
  46.     (when class-default-initargs
  47.       (setf initargs (default-initargs class initargs class-default-initargs)))
  48.     (when initargs
  49.       (when (and (eq *boot-state* 'complete)
  50.              (not (getf initargs :allow-other-keys)))
  51.         (let ((class-proto (class-prototype class)))
  52.           (check-initargs-1
  53.           class initargs
  54.         (append (compute-applicable-methods
  55.               #'allocate-instance (list* class initargs))
  56.             (compute-applicable-methods 
  57.               #'initialize-instance (list* class-proto initargs))
  58.             (compute-applicable-methods 
  59.               #'shared-initialize (list* class-proto t initargs)))))))
  60.     (let* ((*making-instance-p* T)
  61.            (instance (apply #'allocate-instance class initargs)))
  62.       (apply #'initialize-instance instance initargs)
  63.       instance)))
  64.  
  65. (defmethod make-instance ((class-name symbol) &rest initargs)
  66.   (apply #'make-instance (find-class class-name) initargs))
  67.  
  68. (defvar *default-initargs-flag* (list nil))
  69.  
  70. (defmethod default-initargs ((class slot-class) supplied-initargs all-default)
  71.   ;; This implementation of default initargs is critically dependent
  72.   ;; on all-default-initargs not having any duplicate initargs in it.
  73.   (let ((miss *default-initargs-flag*))
  74.     (flet ((getf* (plist key)
  75.          (do ()
  76.          ((null plist) miss)
  77.            (if (eq (car plist) key)
  78.            (return (cadr plist))
  79.            (setq plist (cddr plist))))))
  80.       (labels ((default-1 (tail)
  81.          (if (null tail)
  82.              nil
  83.              (if (eq (getf* supplied-initargs (caar tail)) miss)
  84.              (list* (caar tail)
  85.                 (funcall-function (cadar tail))
  86.                 (default-1 (cdr tail)))
  87.              (default-1 (cdr tail))))))
  88.     (append supplied-initargs (default-1 all-default))))))
  89.  
  90.  
  91. (defmethod allocate-instance ((class standard-class) &rest initargs)
  92.   (declare (ignore initargs))
  93.   (unless (or *making-instance-p* (class-finalized-p class))
  94.     (finalize-inheritance class))
  95.   (let* ((class-wrapper (class-wrapper class))
  96.          (instance (%allocate-instance--class
  97.                      (wrapper-allocate-static-slot-storage-copy
  98.                        class-wrapper))))
  99.     (setf (std-instance-wrapper instance) class-wrapper)
  100.     instance))
  101.  
  102. (defmethod allocate-instance ((class structure-class) &rest initargs)
  103.   (declare (ignore initargs))
  104.   (let ((constructor (class-defstruct-constructor class)))
  105.     (if constructor
  106.         (funcall-function (symbol-function constructor))
  107.         (error "Can't allocate an instance of class ~S" (class-name class)))))
  108.  
  109. (defmethod initialize-instance ((instance slot-object) &rest initargs)
  110.   (apply #'shared-initialize instance t initargs))
  111.  
  112.  
  113. (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
  114.   (checking-initargs
  115.     (when (and initargs (eq *boot-state* 'complete)
  116.            (not (getf initargs :allow-other-keys)))
  117.       (check-initargs-1
  118.        (class-of instance) initargs
  119.        (append (compute-applicable-methods 
  120.         #'reinitialize-instance (list* instance initargs))
  121.            (compute-applicable-methods 
  122.         #'shared-initialize (list* instance nil initargs))))))
  123.   (apply #'shared-initialize instance nil initargs)
  124.   instance)
  125.  
  126.  
  127. (defmethod update-instance-for-different-class ((previous standard-object)
  128.                         (current standard-object)
  129.                         &rest initargs)
  130.   ;; First we must compute the newly added slots.  The spec defines
  131.   ;; newly added slots as "those local slots for which no slot of
  132.   ;; the same name exists in the previous class."
  133.   (let ((added-slots '())
  134.     (current-slotds (class-slots (class-of current)))
  135.     (previous-slot-names (mapcar #'slot-definition-name
  136.                      (class-slots (class-of previous)))))
  137.     (dolist (slotd current-slotds)
  138.       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
  139.            (eq (slot-definition-allocation slotd) ':instance))
  140.       (push (slot-definition-name slotd) added-slots)))
  141.     (checking-initargs
  142.       (when (and initargs (not (getf initargs :allow-other-keys)))
  143.     (check-initargs-1
  144.      (class-of current) initargs
  145.      (append (compute-applicable-methods 
  146.           #'update-instance-for-different-class 
  147.           (list* previous current initargs))
  148.          (compute-applicable-methods 
  149.           #'shared-initialize (list* current added-slots initargs))))))
  150.     (apply #'shared-initialize current added-slots initargs)))
  151.  
  152. (defmethod update-instance-for-redefined-class ((instance standard-object)
  153.                         added-slots
  154.                         discarded-slots
  155.                         property-list
  156.                         &rest initargs)
  157.   (checking-initargs
  158.     (when (and initargs (not (getf initargs :allow-other-keys)))
  159.       (check-initargs-1
  160.        (class-of instance) initargs
  161.        (append (compute-applicable-methods 
  162.         #'update-instance-for-redefined-class 
  163.         (list* instance added-slots discarded-slots property-list initargs))
  164.            (compute-applicable-methods 
  165.         #'shared-initialize (list instance added-slots initargs))))))
  166.   (apply #'shared-initialize instance added-slots initargs))
  167.  
  168. (defmethod shared-initialize
  169.        ((instance slot-object) slot-names &rest initargs)
  170.   (declare (list initargs))
  171.   (declare #.*optimize-speed*)
  172.   ;;
  173.   ;; initialize the instance's slots in a two step process
  174.   ;;   1. A slot for which one of the initargs in initargs can set
  175.   ;;      the slot, should be set by that initarg.  If more than
  176.   ;;      one initarg in initargs can set the slot, the leftmost
  177.   ;;      one should set it.
  178.   ;;
  179.   ;;   2. Any slot not set by step 1, may be set from its initform
  180.   ;;      by step 2.  Only those slots specified by the slot-names
  181.   ;;      argument are set.  If slot-names is:
  182.   ;;       T
  183.   ;;            any slot not set in step 1 is set from its
  184.   ;;            initform
  185.   ;;       <list of slot names>
  186.   ;;            any slot in the list, and not set in step 1
  187.   ;;            is set from its initform
  188.   ;;
  189.   ;;       ()
  190.   ;;            no slots are set from initforms
  191.   ;;
  192.   (flet
  193.    ((init-safe (slots initing-internal-slotds)
  194.       (dolist (internal-slotd initing-internal-slotds)
  195.        (unless
  196.          (and
  197.            initargs
  198.            ;; Try to initialize the slot from one of the initargs.
  199.            (let ((slot-initargs (internal-slotd-initargs internal-slotd))
  200.                  (initargs-ptr  initargs))
  201.              (loop
  202.                (when (memq (car initargs-ptr) slot-initargs)
  203.                  (let ((location (internal-slotd-location internal-slotd)))
  204.                    (typecase location
  205.                      (fixnum (setf (%svref slots location)
  206.                                    (cadr initargs-ptr)))
  207.                      (cons   (setf (cdr location) (cadr initargs-ptr)))
  208.                      (T (method-function-funcall
  209.                           (internal-slotd-writer-function internal-slotd)
  210.                           (cadr initargs-ptr) instance))))
  211.                    (return 't))
  212.                  (when (null (setf initargs-ptr (cddr initargs-ptr)))
  213.                    (return)))))
  214.            ;; Try to initialize the slot from its initform.
  215.            (when (or (eq slot-names 't)
  216.                      (memq (internal-slotd-name internal-slotd) slot-names))
  217.              (let ((location (internal-slotd-location internal-slotd)))
  218.                (typecase location
  219.                  (fixnum
  220.                    (when (eq (%svref slots location) *slot-unbound*)
  221.                      (let ((initfn (internal-slotd-initfunction
  222.                                       internal-slotd)))
  223.                        (when initfn
  224.                          (setf (%svref slots location)
  225.                                (slot-initfunction-funcall initfn))))))
  226.                  (cons
  227.                    (when (eq (cdr location) *slot-unbound*)
  228.                      (let ((initfn (internal-slotd-initfunction
  229.                                      internal-slotd)))
  230.                        (when initfn
  231.                          (setf (cdr location)
  232.                                     (slot-initfunction-funcall initfn))))))
  233.                  (T
  234.                    (unless (method-function-funcall
  235.                              (internal-slotd-boundp-function internal-slotd)
  236.                              instance)
  237.                      (let ((initfn (internal-slotd-initfunction
  238.                                      internal-slotd)))
  239.                        (when initfn
  240.                          (method-function-funcall
  241.                            (internal-slotd-writer-function internal-slotd)
  242.                            (slot-initfunction-funcall initfn) instance)))))))))))
  243.  
  244.     (init-unsafe (initing-internal-slotds)
  245.       (dolist (internal-slotd initing-internal-slotds)
  246.        (unless
  247.          (and
  248.            initargs
  249.            ;; Try to initialize the slot from one of the initargs.
  250.            (let ((slot-initargs (internal-slotd-initargs internal-slotd))
  251.                  (initargs-ptr  initargs))
  252.              (loop
  253.                (when (memq (car initargs-ptr) slot-initargs)
  254.                  (method-function-funcall
  255.                    (internal-slotd-writer-function internal-slotd)
  256.                    (cadr initargs-ptr) instance)
  257.                  (return 't))
  258.                (when (null (setf initargs-ptr (cddr initargs-ptr)))
  259.                  (return)))))
  260.            ;; Try to initialize the slot from its initform.
  261.            (when (or (eq slot-names 't)
  262.                      (memq (internal-slotd-name internal-slotd) slot-names))
  263.              (unless (method-function-funcall
  264.                        (internal-slotd-boundp-function internal-slotd)
  265.                        instance)
  266.                (let ((initfn (internal-slotd-initfunction internal-slotd)))
  267.                  (when initfn
  268.                    (method-function-funcall
  269.                      (internal-slotd-writer-function internal-slotd)
  270.                      (slot-initfunction-funcall initfn) instance)))))))))
  271.     
  272.     (when (or slot-names initargs)
  273.       (let ((initing-internal-slotds
  274.               (fast-slot-value (class-of instance)
  275.                                (if (and *making-instance-p* (null initargs))
  276.                                    'side-effect-internal-slotds
  277.                                    'internal-slotds))))
  278.       (if *safe-to-use-slot-wrapper-optimizations-p*
  279.           (cond
  280.             ((std-instance-p instance)
  281.              (fast-check-wrapper-validity instance std-instance-wrapper)
  282.              (init-safe (std-instance-slots instance) initing-internal-slotds))
  283.             ((fsc-instance-p instance)
  284.              (fast-check-wrapper-validity instance fsc-instance-wrapper)
  285.              (init-safe (fsc-instance-slots instance) initing-internal-slotds))
  286.             #+pcl-user-instances
  287.             ((user-instance-p instance)
  288.              (fast-check-wrapper-validity instance user-instance-wrapper)
  289.              (init-safe (user-instance-slots instance) initing-internal-slotds))
  290.             (T (init-unsafe initing-internal-slotds)))
  291.           (init-unsafe initing-internal-slotds))))
  292.     instance))
  293.  
  294.  
  295.  
  296. ;;; 
  297. ;;; if initargs are valid return nil, otherwise signal an error
  298. ;;;
  299.  
  300. (declaim (ftype (function (T) (values list boolean)) function-keywords))
  301.  
  302. (defun check-initargs-1 (class initargs methods)
  303.   (let ((legal (apply #'append (mapcar #'internal-slotd-initargs
  304.                        (class-internal-slotds class)))))
  305.     (unless nil ; (getf initargs :allow-other-keys) ; This is already checked.
  306.       ;; Add to the set of slot-filling initargs the set of
  307.       ;; initargs that are accepted by the methods.  If at
  308.       ;; any point we come across &allow-other-keys, we can
  309.       ;; just quit.
  310.       (dolist (method methods)
  311.     (multiple-value-bind (keys allow-other-keys)
  312.         (function-keywords method)
  313.           (declare (type boolean allow-other-keys))
  314.       (when allow-other-keys
  315.         (return-from check-initargs-1 nil))
  316.       (setq legal (append keys legal))))
  317.       ;; Now check the supplied-initarg-names and the default initargs
  318.       ;; against the total set that we know are legal.
  319.       (doplist (key val) initargs
  320.     (unless (memq key legal)
  321.       (error "Invalid initialization argument ~S for class ~S"
  322.          key
  323.          (class-name class)))))))
  324.  
  325.